Het volgende voorbeeld maakt een formulier met een keuzelijst die een alfabetisch gesorteerde lijst bevat van de lettertypen in uw systeem.
Als u dit voorbeeld wilt uitvoeren, maakt u een formulier met een keuzelijst. De code voor het formulier ziet er als volgt uit:
Option Explicit
Private Sub Form_Load()
Module1.FillListWithFonts List1
End Sub
Plaats de volgende programmacode in een module. Het derde argument in de definitie van de functie EnumFontFamilies is een Long die een procedure voorstelt. Het argument moet het adres van de procedure bevatten, niet de waarde die de procedure oplevert. In de aanroep van EnumFontFamilies vereist het derde argument dat de operator AddressOf het adres van de procedure EnumFontFamProc teruggeeft. Dat wordt de naam van de callback procedure die u doorgeeft bij het aanroepen van de Windows API-functie EnumFontFamilies. Windows activeert EnumFontFamProc eenmaal voor elke lettertypefamilie op het systeem wanneer u AddressOf EnumFontFamProc aan EnumFontFamilies doorgeeft. Het laatste argument dat aan EnumFontFamilies wordt doorgegeven, noemt de keuzelijst waarin de informatie wordt weergegeven.
'Opsommingstypen voor het lettertype
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
' vlaggen voor ntmFlags-velden
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
' tmPitchAndFamily-vlaggen
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
' EnumFonts-maskers
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Declare Function EnumFontFamilies Lib "gdi32" Alias _
"EnumFontFamiliesA" _
(ByVal hDC As Long, ByVal lpszFamily As String, _
ByVal lpEnumFontFamProc As Long, LParam As Any) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, LParam As ListBox) As Long
Dim FaceName As String
Dim FullName As String
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
LParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
EnumFontFamProc = 1
End Function
Sub FillListWithFonts(LB As ListBox)
Dim hDC As Long
LB.Clear
hDC = GetDC(LB.hWnd)
EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, LB
ReleaseDC LB.hWnd, hDC
End Sub